      SUBROUTINE DECODE2
C*****THIS SUBROUTINE READS A CODEV DATA FILE
C
C**  COMMON BLOCK CODEV DECLARATIONS
      CHARACTER*4 DIM,APERT(225)
      INTEGER*4 ICCY(0:225),ITHC(0:225),IGLC(0:225),IWTW1,IWTW2,IWTW3
      INTEGER*4 IWTW4,IWTW5,IWTW6,IWTW7,ICCX(30),KC(66),IAC(66),IBC(66)
      INTEGER*4 ICC(66),IDC(66),IXDC(100),IYDC(100),IADC(100),IBDC(100)
      INTEGER*4 ICDC(100),ICCF(66)
      REAL*4 ORDER(66),WLF1,WLF2,WLF3,WLF4,WLF5,WLF6,WLF7
      REAL*4 F(225),AL(66),AM(66),AN(66)
      REAL*8 RFND1(20),RFND2(20),RFND3(20),RFND4(20),RFND5(20)
C** COMMON BLOCK BOTH DECLARATIONS
      CHARACTER*4 SOLVE(40)
      CHARACTER*13 GLASS(0:225)
      CHARACTER*64 TITLE
      INTEGER*4 I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,M,ISTOP,IREF,ISURF
      INTEGER*4 NAPERT(225),NDECE(100),NSOLVE(40),NUMA,MESSAGE(20)
      REAL*4 DIF(66)
      REAL*8 ADE(100),BDE(100),CDE(100),XDE(100),YDE(100),CURVEY(0:225)
      REAL*8 THICKNS(0:225),RK(66),A(66),B(66),C(66),D(66),SOLVF1(40)
      REAL*8 F1(225)
      LOGICAL AFO,IC(66),CUF(66)
C** COMMON BLOCK CAONLY DECLARATIONS
      CHARACTER*3 SURFMES(20),SOLVE1(40),SOLVE2(40)
      CHARACTER*4 TYPE(66)
      CHARACTER*13 CATALOG(20),MATRL(20),GL(0:225)
      CHARACTER*24 SUBMES4(20)
      INTEGER*4 NTYPE(66),NRETUT(100),NRETUF(100),IPKCV1(200)
      INTEGER*4 IPKAD1(200),IPKAD2(200),IPKAE1(200),IPKAE2(200)
      INTEGER*4 IPKAF1(200),IPKAF2(200),IPKAG1(200),IPKAG2(200)
      INTEGER*4 IPKA1(200),IPKA2(200),IPKB1(200),IPKB2(200),IPKG1(200)
      INTEGER*4 IPKG2(200),IPKX1(200),IPKX2(200),IPKY1(200),IPKY2(200)
      INTEGER*4 IPKGL1(200),IPKGL2(200),IPKTH1(200),IPKTH2(200)
      INTEGER*4 IPKCC1(200),IPKCC2(200),ICCA(200),ICVA(200),ITHA(200)
      INTEGER*4 IGLA(200),IAEA(200),IAFA(200),IAGA(200),IADA(200)
      INTEGER*4 IXA(200),IYA(200),IAA(200),IBA(200),IGA(200),J1,J2,J3
      INTEGER*4 J4,J5,J6,J7,J8,J9,JE,JF,JG,JD,JX,JY,JA,JB,JM
      INTEGER*4 INDICE(225),ICIR(225),IRECT(225),IELIP(225),ICOCYF(20)
      INTEGER*4 ICOCYT(20),ICOCXF(20),ICOCXT(20),TILT(66),RTILT(66)
      INTEGER*4 RDECE(100),MESNUM(20),IPKCV2(200)
      REAL*4 WL1(20),WL2(20),WL3(20),WL4(20),WL5(20),WL6(20),WL7(20)
      REAL*4 TWL1(20),TWL2(20),TWL3(20),TWL4(20),TWL5(20)
      REAL*4 CATWL1(20),CATWL2(20),CATWL3(20),CATWL4(20),CATWL5(20)
      REAL*4 CATWL6(20),CATWL7(20),W1(20),W2(20),W3(20),W4(20),W5(20)
      REAL*4 IND1(20),IND2(20),IND3(20),IND4(20),IND5(20),TIND1(20)
      REAL*4 TIND2(20),TIND3(20),TIND4(20),TIND5(20)
      REAL*8 UMARG,YMARG,UCHIEF,UMARG,CUX(30),RADE(100),RBDE(100)
      REAL*8 RCDE(100),RXDE(100),RYDE(100)
      LOGICAL VIGNET,TEL,RETURN(100),ZMFLAG
C** LOCAL DECLARATIONS
      CHARACTER*110 LINE
      CHARACTER*4 FLAG1,FLAG2
      REAL*4 WAVE1,WAVE2
C
      COMMON /CODEV/DIM,APERT,ICCY,ITHC,IGLC,IWTW1,IWTW2,IWTW3,IWTW4,
     *        IWTW5,IWTW6,ILWTW7,ICCX,KC,IAC,IBC,ICC,IDC,ORDER,IXDC,
     *        IYDC,IADC,IBDC,ICDC,ICCF,WLF1,WLF2,WLF3,WLF4,WLF5,WLF6,
     *        WLF7,RFND1,RFND2,RFND3,RFND4,RFND5,F,AL,AM,AN
      COMMON /BOTH/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,GLASS,MESSAGE,M,
     *        ISTOP,IREF,ISURF,AFO,NAPERT,NDECE,F1,DIF,ADE,BDE,CDE,XDE,
     *        YDE,CURVEY,THICKNS,RK,A,B,C,D,IC,CUF,NSOLVE,SOLVF1,SOLVE,
     *        TITLE,NUMA
      COMMON /CAONLY/UMARG,YMARG,UCHIEF,YCHIEF,TYPE,NTYPE,NRETUT,
     *        NRETUF,CATWL1,CATWL2,CATWL3,CATWL4,CATWL5,CATWL6,CATWL7,
     *        CUX,VIGNET,TEL,RETURN,MATRL,SOLVE1,SOLVE2,ZMFLAG,SURFMES,
     *        CATALOG,WL1,WL2,WL3,WL4,WL5,WL6,WL7,IND1,IND2,IND3,IN4,
     *        IND5,TWL1,TWL2,TWL3,TWL4,TWL5,TIND1,TIND2,TIND3,TIND4,
     *        TIND5,GL,IPKCV1,IPKCV2,IPKAD1,IPKAD2,IPKAE1,IPKAE2,
     *        IPKAF1,IPKAF2,IPKAG1,IPKAG2,IPKA1,IPKA2,IPKB1,IPKB2,
     *        IPKG1,IPKG2,IPKX1,IPKX2,IPKY1,IPKY2,IPKTH1,IPKTH2,IPKCC1,
     *        IPKCC2,ICCA,ICVA,ITHA,IGLA,IAEA,IAFA,IAGA,IADA,IXA,IYA,
     *        IAA,IBA,IGA,J1,J2,J3,J4,J5,J6,J7,J8,J9,JE,JF,JG,JD,JX,JY,
     *        JA,JB,JM,INDICE,ICIR,IRECT,IELIP,ICOCYF,ICOCYT,ICOCXF,
     *        ICOCXT,TILT,RTILT,W1,W2,W3,W4,W5,RDECE,RADE,RBDE,RCDE,
     *        RXDE,RYDE,MESNUM,SUBMES4
C
C*******************************************************************************
C*****FORMAT STATEMENTS
  2   FORMAT(A110)
  4   FORMAT(5X,F14.8,I4,6X,F15.6,1X,I4,8X,A13,1X,I4,22X,A1,A7)
  6   FORMAT(16X,2F12.6,3X,F10.6,3X,F10.6,3X,F10.6,4X,A4)
  8   FORMAT(19X,I4,9X,I4,9X,I4,9X,I4,9X,I4)
 10   FORMAT(16X,I6)
 12   FORMAT(29X,A1)
 14   FORMAT(21X,F10.2,3X,F10.2,3X,F10.2,3X,F10.2,3X,F10.2,3X,F10.2,
     *   3X,F10.2)
 15   FORMAT(26X,I4,9X,I4,9X,I4,9X,I4,9X,I4,9X,I4,9X,I4)
 16   FORMAT(7X,A3,I3,6X,F12.5)
 18   FORMAT(22X,F8.2,5X,F8.2,5X,F8.2,5X,F8.2,5X,F8.2,5X,F8.2,5X,F8.2)
 19   FORMAT(7X,A13,14X,F9.6,4X,F9.6,4X,F9.6,4X,F9.6,4X,F9.6)
 20   FORMAT(7X,A13,1X,F9.6,4X,F9.6,4X,F9.6,4X,F9.6,4X,F9.6)
 22   FORMAT(3X,F13.8,4X,I3,7X,F10.6,14X,F12.8,6X,I3)
 24   FORMAT(5X,F14.6,I4,8X,F13.6,2X,I3,6X,F13.6,4X,I3,2X,F13.6,3X,I3)
 26   FORMAT(12X,F10.6,4X,F10.6,4X,F10.6,4X,F10.6,4X,F10.6)
 28   FORMAT(5X,F14.8,I4)
 30   FORMAT(26X,I4)
 31   FORMAT(48X,F11.6)
 32   FORMAT(3X,F11.6,F11.6,11X,F11.6)
 34   FORMAT(5X,A46)
 36   FORMAT(7X,A3,I3,1X,A3,4X,F9.6)
 38   FORMAT(41X,F10.2)
C*******************************************************************************
C*****INITIALIZE
C
      I=0
      I1=1
      I2=1
      I3=1
      I4=1
      I5=1
      I6=1
      I7=1
      M=1
      DO 100,J=1,20
        CATWL1(J)=0.0
        CATWL2(J)=0.0
        CATWL3(J)=0.0
        CATWL4(J)=0.0
        CATWL5(J)=0.0
        CATWL6(J)=0.0
        CATWL7(J)=0.0
        WL1(J)=0.0
        WL2(J)=0.0
        WL3(J)=0.0
        WL4(J)=0.0
        WL5(J)=0.0
        WL6(J)=0.0
        WL7(J)=0.0
100     CONTINUE
      DO 105,J=1,66
        IC(J)=.FALSE.
105   CONTINUE
      DO 110,J=1,100
        RETURN(J)=.FALSE.
110   CONTINUE
      ZMFLAG=.FALSE.
      VIGNET=.FALSE.
      IREF=0.0
      DIM=' '
      WLF1=0.0
      WLF2=0.0
      WLF3=0.0
      WLF4=0.0
      WLF5=0.0
      WLF6=0.0
      WLF7=0.0
      IWTW1=0
      IWTW2=0
      IWTW3=0
      IWTW4=0
      IWTW5=0
      IWTW6=0
      IWTW7=0
C******************************************************************************
C*****TITLE
180   READ(6,2)LINE
      READ(6,2)LINE
      READ(6,34)TITLE
C*******************************************************************************
C*****SURFACE DATA
C
200   READ(6,2)LINE
      IF (LINE(6:9) .NE. 'SURF') GOTO 200
205   READ(6,2)LINE
      IF (LINE(2:4) .NE. 'OBJ') GOTO 205
208   IF (LINE(9:12) .EQ. 'DECE') GOTO 210
      IF (LINE(9:12) .EQ. 'RETU') GOTO 215
      IF (LINE(9:12) .EQ. ' ') GOTO 223
      IF ((LINE(6:7) .EQ. '**') .OR. (LINE(6:7) .EQ. '--')) GOTO  225
C*****SIMPLE SURFACE DATA - 1 DATA LINE
      READ(LINE,4)CURVEY(I),ICCY(I),THICKNS(I),ITHC(I),GLASS(I),IGLC(I),
     *  FLAG1,FLAG2
      IF (FLAG1 .EQ. 'S') ISTOP=I
      IF (FLAG2 .NE. ' ') THEN /*SPECIAL SURFACE - 1 OR 2 DATA LINES
         TYPE(I4)=FLAG2
         NTYPE(I4)=I
         IF (TYPE(I4) .EQ. 'CYL') THEN
           READ(6,28)CUX(I4),ICCX(I4)
           I4=I4+1
           GOTO 220
          END IF
C******SURFACES NOT HANDLED
       IF ((TYPE(I4) .EQ. 'SPL') .OR. (TYPE(I4) .EQ. 'CON') .OR.
     *    (TYPE(I4) .EQ. 'THG') .OR. (TYPE(I4) .EQ. 'HOE') .OR.
     *    (TYPE(I4) .EQ. 'AAS')) GOTO 217
         IF (TYPE(I4) .EQ. 'CYL') THEN
           READ(6,28)CUX(I4),ICCX(I4)
           I4=I4+1
           GOTO 220
         END IF
         READ(6,22)RK(I4),KC(I4),FLAG3,FLAG4,ICCF(I4)
         READ(6,24)A(I4),IAC(I4),B(I4),IBC(I4),C(I4),ICC(I4),D(I4),
     *     IDC(I4)
         IF (FLAG4 .GT. 0) CUF(I)=.TRUE.
         IF (FLAG3 .EQ. -1.0) IC(I4)=.TRUE.
         IF (TYPE(I4) .EQ. 'GRT') READ(6,26)ORDER(I4),DIF(I4),AL(I4),
     *     AM(I4),AN(I4)
         IF (TYPE(I4) .EQ. 'YTO') READ(6,28)CUX(I4),ICCX(I4)
         I4=I4+1
        ELSE
          GOTO 220
      END IF
      GOTO 220
C*****DECENTER DATA - 2 DATA LINES
210   READ(LINE,6)XDE(I2),YDE(I2),ADE(I2),BDE(I2),CDE(I2),FLAG1
      IF (FLAG1 .EQ. 'RETU') RETURN(I2)=.TRUE.
      NDECE(I2)=I
      READ(6,8)IXDC(I2),IYDC(I2),IADC(I2),IBDC(I2),ICDC(I2)
      I2=I2+1
      GOTO 223
C*****RETURN ONLY DATA - 1 DATA LINE
215   READ(LINE,10)ITEMP
      NRETUT(I3)=ITEMP
      NRETUF(I3)=I
      I3=I3+1
      GOTO 223
C*****SURFACES NOT HANDLED
217   IF (TYPE(I4) .EQ. 'SPL') I=3
      IF (TYPE(I4) .EQ. 'CON') I=1
      IF (TYPE(I4) .EQ. 'THG') I=4
      IF (TYPE(I4) .EQ. 'HOE') I=4
      IF (TYPE(I4) .EQ. 'AAS') I=4
      MESSAGE(M)=4
      SURFMES(M)=TYPE(I4)
      M=M+1
      DO 218,K=1,I
        READ(6,2)LINE  /* SKIP SPECIAL SURFACE DATA LINES
218   CONTINUE
      GOTO 223
220   I=I+1
223   READ(6,2)LINE
      GOTO 208
225   ISURF=I-1 /*TOTAL NUMBER OF SURFACES
C*******************************************************************************
C*****SPECIFICATION DATA
228   READ(6,2)LINE
      IF (LINE(6:9) .NE. 'SPEC') GOTO 228
      READ(6,2)LINE  /*SKIP 3 BLANK LINES
      READ(6,2)LINE
      READ(6,2)LINE
230   READ(6,2)LINE
      IF (LINE(8:10) .EQ. 'DIM') THEN
       READ(LINE,12)DIM
       ELSE IF (LINE(8:10) .EQ. 'WL') THEN
        READ(LINE,14)WLF1,WLF2,WLF3,WLF4,WLF5,WLF6,WLF7
         IF (WLF1 .GT. 0.0) J=1 /*COUNT WAVE LENGTHS
         IF (WLF2 .GT. 0.0) J=2
         IF (WLF3 .GT. 0.0) J=3
         IF (WLF4 .GT. 0.0) J=4
         IF (WLF5 .GT. 0.0) J=5
         IF (WLF6 .GT. 0.0) J=6
         IF (WLF7 .GT. 0.0) THEN
          WLF1=WLF2   /* IF MORE THAN 7 WAVE LENGTHS
          WLF2=WLF3   /* THROW FIRST AWAY
          WLF3=WLF4
          WLF4=WLF5
          WLF5=WLF6
          J=7
         END IF
        ELSE IF (LINE(8:10) .EQ. 'WTW') THEN
         READ(LINE,15)IWTW1,IWTW2,IWTW3,IWTW4,IWTW5
         IF (IWTW7 .GT. 0) THEN
           IWTW1=IWTW2
           IWTW2=IWTW3
           IWTW3=IWTW4
           IWTW4=IWTW5
           IWTW5=IWTW6
         END IF
         ELSE IF (LINE(8:10) .EQ. 'REF') THEN
          READ(LINE,30)IREF
          ELSE IF (LINE(8:10) .EQ. 'AFO') THEN
           AFO=.TRUE.
           ELSE IF ((LINE(8:10) .EQ. 'VUY') .OR.
     *       (LINE(8:10) .EQ. 'VUX')) THEN
            IF (VIGNET) GOTO 230
            MESSAGE(M)=1
            M=M+1
            VIGNET=.TRUE.
           ELSE IF (LINE(8:10) .EQ. 'VUX') THEN
            MESSAGE(M)=1
            M=M+1
            ELSE IF (LINE(8:10) .EQ. 'TEL') THEN
             MESSAGE(M)=2
             M=M+1
             ELSE IF (LINE(8:10) .EQ. ' ') THEN
              GOTO 300
       END IF
      GOTO 230
C*******************************************************************************
C*****DETERMINE NEXT CATEGORY
300   READ(6,2)LINE
      IF (LINE(6:13) .EQ. 'APERTURE') THEN
        GOTO 305
       ELSE IF (LINE(6:12) .EQ. 'PRIVATE') THEN
         GOTO 320
        ELSE IF (LINE(6:15) .EQ. 'REFRACTIVE') THEN
          GOTO 340
         ELSE IF (LINE(6:10) .EQ. 'SOLVE') THEN
           GOTO 350
          ELSE IF (LINE(6:9) .EQ. 'ZOOM') THEN
            GOTO 400
           ELSE IF (LINE(5:7) .EQ. 'ANA') THEN
             GOTO 500
      END IF
      GOTO 300
C*******************************************************************************
C*****APERTURE DATA
305   READ(6,2)LINE /*SKIP A LINE
310   READ(6,2)LINE
      IF (LINE(8:10) .EQ. ' ') GOTO 300
      READ(LINE,16)APERT(I1),NAPERT(I1),F1(I1)
      IF ((APERT(I1) .EQ. 'ADX ') .OR. (APERT(I1) .EQ. 'ADY ') .OR.
     *    (APERT(I1) .EQ. 'AGR ') .OR. (APERT(I1) .EQ. 'CIG ') .OR.
     *    (APERT(I1) .EQ. 'REG ') .OR. (APERT(I1) .EQ. 'ELG ') .OR.
     *    (APERT(I1) .EQ. 'ORA ')) THEN
       SUBMES4(M)=LINE(8:31)
       MESSAGE(M)=7
       M=M+1
       IF (APERT(I1) .EQ. 'ORA ') READ(6,2)LINE /*SKIP A LINE
      ELSE
        I1=I1+1
      END IF
      GOTO 310
C*******************************************************************************
C*****PRIVATE CATALOG
320   READ(6,2)LINE /*SKIP 2 BLANK LINES
      READ(6,2)LINE
      READ(6,2)LINE
325   READ(LINE,18)CATWL1(I5),CATWL2(I5),CATWL3(I5),CATWL4(I5),
     *  CATWL5(I5),CATWL6(I5),CATWL7(I5)
        IF (CATWL7(I5) .GT. 0.0) THEN
          CATWL1(I5)=CATWL2(I5)
          CATWL2(I5)=CATWL3(I5)
          CATWL3(I5)=CATWL4(I5)
          CATWL4(I5)=CATWL5(I5)
          CATWL5(I5)=CATWL6(I5)
          READ(6,19)CATALOG(I5),RFND1(I5),RFND2(I5),RFND3(I5),RFND4(I5),
     *    RFND5(I5)
        ELSE
330       READ(6,20)CATALOG(I5),RFND1(I5),RFND2(I5),RFND3(I5),RFND4(I5),
     *    RFND5(I5)
        END IF
      READ(6,2)LINE
      IF (LINE(8:17) .EQ. ' ') THEN
        GOTO 300
        ELSE IF (LINE(8:9) .NE.'WL') THEN
          I5=I5+1
          CATWL1(I5)=CATWL1(I5-1)
          CATWL2(I5)=CATWL2(I5-1)
          CATWL3(I5)=CATWL3(I5-1)
          CATWL4(I5)=CATWL4(I5-1)
          CATWL5(I5)=CATWL5(I5-1)
          GOTO 330
        ELSE
          I5=I5+1
          GOTO 325
       END IF
C*******************************************************************************
C*****REFRACTIVE INDICES
340   READ(6,2)LINE /*SKIP A LINE
      READ(6,18)WL1(I7),WL2(I7),WL3(I7),WL4(I7),WL5(I7),
     *  WL6(I7),WL7(I7)
        IF (WL7(I7) .GT. 0.0) THEN
          WL1(I7)=WL2(I7)
          WL2(I7)=WL3(I7)
          WL3(I7)=WL4(I7)
          WL4(I7)=WL5(I7)
          WL5(I7)=WL6(I7)
          READ(6,19)MATRL(I5),IND1(I7),IND2(I7),IND3(I7),IND4(I7),
     *    IND5(I7)
        ELSE
345       READ(6,20)MATRL(I5),IND1(I7),IND2(I7),IND3(I7),IND4(I7),
     *    IND5(I7)
        END IF
      IF (MATRL(I5) .EQ. ' ') THEN
        I7=I7-1 /*IGNORE CLASS CODE WITHOUT INDEX.
        GOTO 300
       END IF
      IND1(I7)=ABS(IND1(I7))
      IND2(I7)=ABS(IND2(I7))
      IND3(I7)=ABS(IND3(I7))
      IND4(I7)=ABS(IND4(I7))
      IND5(I7)=ABS(IND5(I7))
      READ(6,2)LINE
      IF (LINE(8:11) .EQ. ' ') GOTO 300
      I7=I7+1
      WL1(I7)=WL1(I7-1)
      WL2(I7)=WL2(I7-1)
      WL3(I7)=WL3(I7-1)
      WL4(I7)=WL4(I7-1)
      WL5(I7)=WL5(I7-1)
      GOTO 345
C*******************************************************************************
C*****SOLVES
350   READ(6,2)LINE
355   READ(6,2)LINE
      IF (LINE(8:10) .EQ. ' ') GOTO 300
      READ(LINE,36)SOLVE1(I6),NSOLVE(I6),SOLVE2(I6),SOLVF1(I6)
C*****SOLVES NOT TRANSLATED
      IF ((SOLVE2(I6) .EQ. 'ET ') .OR. (SOLVE2(I6) .EQ. 'OAL')) GOTO 355
      IF ((SOLVE1(I6) .EQ. 'RED') .OR. (SOLVE1(I6) .EQ. 'SUR')) GOTO 355
      I6=I6+1
      GOTO 355
C*******************************************************************************
C*****ZOOM
400   MESSAGE(M)=3
      M=M+1
      ZMFLAG=.TRUE.
      GOTO 300
C*******************************************************************************
C*****ANALYSIS
500   READ(6,2)LINE
      READ(6,2)LINE
      IF (LINE(10:12) .NE. 'FIR') GOTO 300 /*WRONG ANALYSIS SECTION
      IF (ZMFLAG) THEN
        I=(J+1)/2
        IF (I .EQ. 1) THEN
          WAVE1=WLF1
        ELSE IF (I .EQ. 2) THEN
          WAVE1=WLF2
        ELSE IF (I .EQ. 3) THEN
          WAVE1=WLF3
        END IF
510     READ(6,2)LINE
        IF (LINE(25:39) .NE. 'PARAXIAL VALUES') GOTO 510
        READ(LINE,38)WAVE2
        IF (WAVE1 .NE. WAVE2) GOTO 510
        DO 515,K=1,6
          READ(6,2)LINE
515     CONTINUE
        IF (LINE(2:3) .NE. 'EP') GOTO 510
        IF (THICKNS(0) .EQ. 0D0) READ(6,2)LINE
        READ(LINE,31)UCHIEF
        READ(6,32)YMARG,UMARG,YCHIEF
      ELSE
520     READ(6,2)LINE
        IF (LINE(2:3) .NE. 'EP') GOTO 520
        IF (THICKNS(0) .EQ. 0D0) READ(6,2)LINE
        READ(LINE,31)UCHIEF
        READ(6,32)YMARG,UMARG,YCHIEF
      END IF
C*******************************************************************************
C*****TEST SECTION
C      PRINT*, 'ISURF:',ISURF
C      PRINT*, 'TITLE; ',TITLE
C      DO 600,J=0,ISURF
C        PRINT*, 'SURFACE: ',J,'CURVATURE: ',CURVEY(J),'THICKNESS: ',
C     *    THICKNS(J)
C        PRINT*, 'THC: ',ITHC(J),'GLASS: ',GLASS(J),'GLC: ',IGLC(J)
C      PRINT*, 'CCY:',ICCY(J)
C600   CONTINUE
C      PRINT*, 'STOP SURF: ',ISTOP
C      DO 610,J=1,I4
C      PRINT*, 'SPECIAL TYPE: ',TYPE(J),'SURFACE: ',NTYPE(J)
C      PRINT*, 'K: ',RK(J),' C:',KC(J),' IC:',IC(J),' CUF:',CUF(J),
C     *   'CCF:',ICCF(J)
C      PRINT*, 'A:',A(J),' AC:',IAC(J),' B:',B(J),' BC:',IBC(J),' C:',
C     *   C(J),' CC:',ICC(J),' D:',D(J),' DC:',IDC(J)
C      IF (TYPE(J) .EQ. 'GRT') PRINT*, 'GRT: N:',ORDER(J),' DIF:',
C     *  DIF(J),' L:',AL(J),' M:',AM(J),' N:',AN(J)
C      IF (TYPE(J) .EQ. 'YTO') PRINT*, 'YTO: CUX:',CUX(J),' CC:',ICCX(J)
C610   CONTINUE
C      PRINT*, 'DECENTERS:'
C      DO 620,J=1,I2
C      PRINT*, 'SURFACE:',NDECE(J),' XDE:',XDE(J),' YDE:',YDE(J)
C      PRINT*, 'ADE:',ADE(J),' BDE:',BDE(J),' CDE:',CDE(J),'RETURN:',
C     *   RETURN(J)
C      PRINT*, 'XDC:',IXDC(J),' YDC:',IYDC(J),' ADC:',IADC(J),' BDC:',
C     *   IBDC(J),' CDC:',ICDC(J)
C620   CONTINUE
C      PRINT*, 'RETURN ONLY:'
C      DO 630,J=1,I3
C      PRINT*, 'SURFACE:',NRETUF(J),' RETURN TO:',NRETUT(J)
C630   CONTINUE
C      DO 640,J=1,I1
C      PRINT*, 'APERTURE:',APERT(J),' SURFACE:',NAPERT(J),' SIZE:',F1(J)
C640   CONTINUE
C      PRINT*, 'MATERIALS AND REFRACTIVE INDICES:'
C      DO 650,J=1,I5
C      PRINT*, 'MATERIAL:',MATRL(J)
C      PRINT*, 'WAVE LENGTHS:',CATWL1(J),CATWL2(J),CATWL3(J),CATWL4(J),
C     *  CATWL5(J)
C      PRINT*, 'INDICES:',RFND1(J),RFND2(J),RFND3(J),RFND4(J),RFND5(J)
C650   CONTINUE
C      PRINT*, 'YMARG:',YMARG,' UMARG:',UMARG,' YCHIEF:',YCHIEF,
C     *   ' UCHIEF:',UCHIEF
C*****END TEST SECTION
      RETURN
      END
      SUBROUTINE CONVERT2
C*****THIS SUBROUTINE TRANSLATES CODEV COMMANDS TO ACCOSV COMMANDS
C
C** COMMON BLOCK CODEV DECLARATIONS
      CHARACTER*4 DIM,APERT(225)
      INTEGER*4 ICCY(0:225),ITHC(0:225),IGLC(0:225),IWTW1,IWTW2,IWTW3
      INTEGER*4 IWTW4,IWTW5,IWTW6,IWTW7,ICCX(30),KC(66),IAC(66),IBC(66)
      INTEGER*4 ICC(66),IDC(66),IXDC(100),IYDC(100),IADC(100),IBDC(100)
      INTEGER*4 ICDC(100),ICCF(66)
      REAL*4 ORDER(66),WLF1,WLF2,WLF3,WLF4,WLF5,WLF6,WLF7
      REAL*4 F(225),AL(66),AM(66),AN(66)
      REAL*8 RFND1(20),RFND2(20),RFND3(20),RFND4(20),RFND5(20)
C** COMMON BLOCK BOTH DECLARATIONS
      CHARACTER*4 SOLVE(40)
      CHARACTER*13 GLASS(0:225)
      CHARACTER*64 TITLE
      INTEGER*4 I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,M,ISTOP,IREF,ISURF
      INTEGER*4 NAPERT(225),NDECE(100),NSOLVE(40),NUMA,MESSAGE(20)
      REAL*4 DIF(66)
      REAL*8 ADE(100),BDE(100),CDE(100),XDE(100),YDE(100),CURVEY(0:225)
      REAL*8 THICKNS(0:225),RK(66),A(66),B(66),C(66),D(66),SOLVF1(40)
      REAL*8 F1(225)
      LOGICAL AFO,IC(66),CUF(66)
C** COMMON BLOCK ACCOSV DECLARATIONS
      CHARACTER*6 UNITS
      INTEGER*4 IORDER(66),IWT1,IWT2,IWT3,IWT4,IWT5
      REAL*4 WVW1,WVW2,WVW3,WVW4,WVW5,WT1,WT2,WT3,WT4,WT5,THETA(66)
      REAL*4 RN1
      REAL*8 N1(20),N2(20),N3(20),N4(20),N5(20),F2(225)
C** COMMON BLOCK CAONLY DECLARATIONS
      CHARACTER*3 SURFMES(20),SOLVE1(40),SOLVE2(40)
      CHARACTER*4 TYPE(66)
      CHARACTER*13 CATALOG(20),MATRL(20),GL(0:225)
      CHARACTER*24 SUBMES4(20)
      INTEGER*4 NTYPE(66),NRETUT(100),NRETUF(100),IPKCV1(200)
      INTEGER*4 IPKAD1(200),IPKAD2(200),IPKAE1(200),IPKAE2(200)
      INTEGER*4 IPKAF1(200),IPKAF2(200),IPKAG1(200),IPKAG2(200)
      INTEGER*4 IPKA1(200),IPKA2(200),IPKB1(200),IPKB2(200),IPKG1(200)
      INTEGER*4 IPKG2(200),IPKX1(200),IPKX2(200),IPKY1(200),IPKY2(200)
      INTEGER*4 IPKGL1(200),IPKGL2(200),IPKTH1(200),IPKTH2(200)
      INTEGER*4 IPKCC1(200),IPKCC2(200),ICCA(200),ICVA(200),ITHA(200)
      INTEGER*4 IGLA(200),IAEA(200),IAFA(200),IAGA(200),IADA(200)
      INTEGER*4 IXA(200),IYA(200),IAA(200),IBA(200),IGA(200),J1,J2,J3
      INTEGER*4 J4,J5,J6,J7,J8,J9,JE,JF,JG,JD,JX,JY,JA,JB,JM
      INTEGER*4 INDICE(225),ICIR(225),IRECT(225),IELIP(225),ICOCYF(20)
      INTEGER*4 ICOCYT(20),ICOCXF(20),ICOCXT(20),TILT(66),RTILT(66)
      INTEGER*4 RDECE(100),MESNUM(20),IPKCV2(200)
      REAL*4 WL1(20),WL2(20),WL3(20),WL4(20),WL5(20),WL6(20),WL7(20)
      REAL*4 TWL1(20),TWL2(20),TWL3(20),TWL4(20),TWL5(20)
      REAL*4 CATWL1(20),CATWL2(20),CATWL3(20),CATWL4(20),CATWL5(20)
      REAL*4 CATWL6(20),CATWL7(20),W1(20),W2(20),W3(20),W4(20),W5(20)
      REAL*4 IND1(20),IND2(20),IND3(20),IND4(20),IND5(20),TIND1(20)
      REAL*4 TIND2(20),TIND3(20),TIND4(20),TIND5(20)
      REAL*8 UMARG,YMARG,UCHIEF,UMARG,CUX(30),RADE(100),RBDE(100)
      REAL*8 RCDE(100),RXDE(100),RYDE(100)
      LOGICAL VIGNET,TEL,RETURN(100),ZMFLAG
C** LOCAL DECLARATIONS
      CHARACTER*4 FLAG1,FLAG2
      CHARACTER*15 GLSAVE
      INTEGER*4 IPK(200),Q,DUMMY(100)
      REAL*4 FLAG3,FLAG4,THSAVE,ANGLE
      LOGICAL DFIRST(225)
C
      COMMON /CODEV/DIM,APERT,ICCY,ITHC,IGLC,IWTW1,IWTW2,IWTW3,IWTW4,
     *        IWTW5,IWTW6,ILWTW7,ICCX,KC,IAC,IBC,ICC,IDC,ORDER,IXDC,
     *        IYDC,IADC,IBDC,ICDC,ICCF,WLF1,WLF2,WLF3,WLF4,WLF5,WLF6,
     *        WLF7,RFND1,RFND2,RFND3,RFND4,RFND5,F,AL,AM,AN
      COMMON /BOTH/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,GLASS,MESSAGE,M,
     *        ISTOP,IREF,ISURF,AFO,NAPERT,NDECE,F1,DIF,ADE,BDE,CDE,XDE,
     *        YDE,CURVEY,THICKNS,RK,A,B,C,D,IC,CUF,NSOLVE,SOLVF1,SOLVE,
     *        TITLE,NUMA
      COMMON /ACCOSV/IORDER,WVW1,WVW2,WVW3,WVW4,WVW5,WT1,WT2,WT3,WT4,
     *        WT5,IWT1,IWT2,IWT3,IWT4,IWT5,THETA,F2,RN1,UNITS,N1,
     *        N2,N3,N4,N5
      COMMON /CAONLY/UMARG,YMARG,UCHIEF,YCHIEF,TYPE,NTYPE,NRETUT,
     *        NRETUF,CATWL1,CATWL2,CATWL3,CATWL4,CATWL5,CATWL6,CATWL7,
     *        CUX,VIGNET,TEL,RETURN,MATRL,SOLVE1,SOLVE2,ZMFLAG,SURFMES,
     *        CATALOG,WL1,WL2,WL3,WL4,WL5,WL6,WL7,IND1,IND2,IND3,IN4,
     *        IND5,TWL1,TWL2,TWL3,TWL4,TWL5,TIND1,TIND2,TIND3,TIND4,
     *        TIND5,GL,IPKCV1,IPKCV2,IPKAD1,IPKAD2,IPKAE1,IPKAE2,
     *        IPKAF1,IPKAF2,IPKAG1,IPKAG2,IPKA1,IPKA2,IPKB1,IPKB2,
     *        IPKG1,IPKG2,IPKX1,IPKX2,IPKY1,IPKY2,IPKTH1,IPKTH2,IPKCC1,
     *        IPKCC2,ICCA,ICVA,ITHA,IGLA,IAEA,IAFA,IAGA,IADA,IXA,IYA,
     *        IAA,IBA,IGA,J1,J2,J3,J4,J5,J6,J7,J8,J9,JE,JF,JG,JD,JX,JY,
     *        JA,JB,JM,INDICE,ICIR,IRECT,IELIP,ICOCYF,ICOCYT,ICOCXF,
     *        ICOCXT,TILT,RTILT,W1,W2,W3,W4,W5,RDECE,RADE,RBDE,RCDE,
     *        RXDE,RYDE,MESNUM,SUBMES4
C
C******************************************************************************
C*****INITIALIZE
      DUMMY(1)=0
      J1=0
      J2=0
      J3=0
      J4=0
      J5=0
      J6=0
      J7=0
      J8=0
      J9=0
      JD=0
      JE=0
      JF=0
      JG=0
      JX=0
      JY=0
      JA=0
      JB=0
      JG=0
      WVW1=0.0
      WVW2=0.0
      WVW3=0.0
      WVW4=0.0
      WVW5=0.0
      IWT1=0
      IWT2=0
      IWT3=0
      IWT4=0
      IWT5=0
      DO 100,J=1,20
        W1(J)=0.0
        W2(J)=0.0
        W3(J)=0.0
        W4(J)=0.0
        W5(J)=0.0
        N1(J)=0.0
        N2(J)=0.0
        N3(J)=0.0
        N4(J)=0.0
        N5(J)=0.0
100   CONTINUE
      DO 110,J=1,225
        ICIR(J)=-1
        IRECT(J)=-1
        IELIP(J)=-1
        DFIRST(J)=.FALSE.
110   CONTINUE
      DO 120,J=1,66
        TILT(J)=-1
        RTILT(J)=-1
120   CONTINUE
C******************************************************************************
C*****MAIN PROGRAM BEGINS
C*****SHIFT SURFACES: 1 INTO 0, 2 INTO 1, 3 INTO 2, ETC., IF THICKNESS ON
C***** SURFACE 0 IS 0.
      IF (THICKNS(0) .EQ. 0.0) THEN
        CALL ZEROSHIFT(ISURF,CURVEY,THICKNS,GLASS,NTYPE,ISTOP,NDECE,
     *  NRETUT,NRETUF,NAPERT,NSOLVE,ICCY,ITHC,IGLC,I1,I2,I3,I4,I6)
        M=M+1
        MESSAGE(M)=6
      END IF
C******************************************************************************
C*****DECENTERED SURFACES WITH RETURNS
      DO 150,J=1,I2-1
        IF (RETURN(J)) THEN
          J8=J8+1
          THSAVE=THICKNS(NDECE(J))
          THICKNS(NDECE(J))=0.0
          GLSAVE=GLASS(NDECE(J))
          GLASS(NDECE(J))='        '
          CALL SHIFT(NDECE(J)+1,ISURF,CURVEY,THICKNS,GLASS,NTYPE,ISTOP,
     *      NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,ICCY,ITHC,IGLC,RDECE,
     *      I1,I2,I3,I4,I6,J8)
          RDECE(J8)=NDECE(J)+1
          RADE(J8)=ADE(J)
          RBDE(J8)=BDE(J)
          RCDE(J8)=CDE(J)
          RXDE(J8)=XDE(J)
          RYDE(J8)=YDE(J)
          THICKNS(NDECE(J)+1)=THSAVE
          GLASS(NDECE(J))=GLSAVE
          IF ((ITHC(NDECE(J)) .NE. 0) .AND.
     *        (ITHC(NDECE(J)) .NE. 100)) THEN
            ITHC(NDECE(J)+1)=ITHC(NDECE(J))
            ITHC(NDECE(J))=0
          END IF
        END IF
        DO 140,K=1,I4-1
          IF ((TYPE(K) .EQ. 'GRT') .AND. (NTYPE(K) .EQ. NDECE(J)))
     *      DFIRST(NDECE(J))=.TRUE.
140     CONTINUE
150   CONTINUE
C******************************************************************************
C*****SPECIAL SURFACES
      DO 175,J=1,I4-1
        IF (TYPE(J) .EQ. 'GRT') THEN
          IORDER (J)=INT(ORDER(J))  /*CONVERT DIF TO MICRONS
          IF (DIM .EQ. 'I   ') DIF(J)=25400.0*DIF(J)
          IF (DIM .EQ. 'C   ') DIF(J)=10000.0*DIF(J)
          IF (DIM .EQ. 'M   ') DIF(J)=1000.0*DIF(J)
          Q=0
C***  CASE 1: L=+-1  M=0  N=0
          IF ((ABS(AL(J)) .EQ. 1.0) .AND. (AM(J) .EQ. 0.0) .AND.
     *      (AN(J) .EQ. 0.0)) THEN
            DIF(J)=DIF(J)
C***  CASE 2: L=0  M=+-1  N=0
          ELSE IF ((AL(J) .EQ. 0.0) .AND. (ABS(AM(J)) .EQ. 1.0) .AND.
     *      (AN(J) .EQ. 0.0)) THEN
            IF (DFIRST(NTYPE(J))) THEN  /* DFIRST SIGNALS A DECENTER & RETURN
C                                       /* WHICH TRANSLATES TO 2 SURFACES. THE
              DO 152,K=1,J8             /* GRT TRANSLATES TO 3 SURFACES BETWEEN
C*                                      /* THE DECENTER AND RETURN SURFACES
                IF (RDECE(K) .EQ. (NTYPE(J)+1)) Q=1
152           CONTINUE
              IF (Q .NE. 1)  /*MAKE ROOM FOR ONESHIFT IF RETURN DOESN'T EXIST
     *           CALL SHIFT(NTYPE(J)+1,ISURF,CURVEY,THICKNS,GLASS,
     *            NTYPE,ISTOP,NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,
     *            ICCY,ITHC,IGLC,RDECE,I1,I2,I3,I4,I6,J8)
              CALL ONESHIFT(NTYPE(J),CURVEY,THICKNS,GLASS,
     *         ISTOP,NAPERT,NSOLVE,ICCY,ITHC,IGLC,I1,I4,I6)
C**** SHIFT DATA TO MAKE ROOM FOR 1ST GRATING SURFACE
              ELSE
              Q=0
            END IF
            DIF(J)=DIF(J)
            J9=J9+1
            TILT(J9)=NTYPE(J)
            THETA(J9)=-90.0
            THSAVE=THICKNS(NTYPE(J))
            CALL SHIFT(NTYPE(J),ISURF,CURVEY,THICKNS,GLASS,NTYPE,
     *       ISTOP,NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,ICCY,ITHC,IGLC,
     *       RDECE,I1,I2,I3,I4,I6,J8)
C***  SHIFT DATA TO MAKE ROOM FOR 2ND GRATING SURFACE
            THICKNS(NTYPE(J))=0.0
            CALL SHIFT(NTYPE(J)+1,ISURF,CURVEY,THICKNS,GLASS,NTYPE,
     *       ISTOP,NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,ICCY,ITHC,IGLC,
     *       RDECE,I1,I2,I3,I4,I6,J8)
            RTILT(J9)=NTYPE(J)+1
C***   SHIFT DATA TO MAKE ROOM FOR 3RD GRATING SURFACE
            IF (Q .EQ. 1) THEN
              CALL SHIFT(NTYPE(J)+2,ISURF,CURVEY,THICKNS,GLASS,NTYPE,
     *         ISTOP,NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,ICCY,ITHC,IGLC,
     *         RDECE,I1,I2,I3,I4,I6,J8)     /* SHIFT DATA TO MAKE ROOM FOR
              THICKNS(NTYPE(J)+2)=THSAVE    /* DECENTER RETURN SURFACE IF IT
              IF ((ITHC(NTYPE(J)) .NE. 0) .AND.  /*EXISTS AND PUT THICKNESS HERE
     *            (ITHC(NTYPE(J)) .NE. 100)) THEN
                ITHC(NTYPE(J)+2)=ITHC(NTYPE(J))
                ITHC(NTYPE(J))=0  /*PICKUP UP STAYS WITH THICKNESS SURFACE
              END IF
              DO 155,K=1,J8
                IF (RDECE(K) .EQ. NTYPE(J)) RDECE(K)=RDECE(K)+2
155            CONTINUE
            ELSE
              THICKNS(NTYPE(J)+1)=THSAVE    /* THICKNESS GOES ON 2ND GRATING
              IF ((ITHC(NTYPE(J)) .NE. 0) .AND. /*SURFACE IF NOT DECENTER
     *            (ITHC(NTYPE(J)) .NE. 100)) THEN /*RETURN SURFACE.  PICKUP
                 ITHC(NTYPE(J)+1)=ITHC(NTYPE(J))  /*STAYS WITH THICKNESS
                 ITHC(NTYPE(J))=0                 /*SURFACE
              END IF
            END IF
C***  CASE 3: -1<L<1  -1<M<1  N=0
          ELSE IF (AN(J) .EQ. 0.0) THEN
            IF (DFIRST(NTYPE(J))) THEN  /* DFIRST SIGNALS A DECENTER & RETURN
C                                       /* WHICH TRANSLATES TO 2 SURFACES. THE
              DO 157,K=1,J8             /* GRT TRANSLATES TO 3 SURFACES BETWEEN
C*                                      /* THE DECENTER AND RETURN SURFACES
                IF (RDECE(K) .EQ. (NTYPE(J)+1)) Q=1
157           CONTINUE
              IF (Q .NE. 1)  /*MAKE ROOM FOR ONESHIFT IF RETURN DOESN'T EXIST
     *           CALL SHIFT(NTYPE(J)+1,ISURF,CURVEY,THICKNS,GLASS,
     *            NTYPE,ISTOP,NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,
     *            ICCY,ITHC,IGLC,RDECE,I1,I2,I3,I4,I6,J8)
              CALL ONESHIFT(NTYPE(J),CURVEY,THICKNS,GLASS,
     *         ISTOP,NAPERT,NSOLVE,ICCY,ITHC,IGLC,I1,I4,I6)
C**** SHIFT DATA TO MAKE ROOM FOR 1ST GRATING SURFACE
              ELSE
              Q=0
            END IF
            DIF(J)=DIF(J)
            J9=J9+1
            TILT(J9)=NTYPE(J)
            THETA(J9)=ATAN(AM(J)/AL(J))
            THSAVE=THICKNS(NTYPE(J))
            CALL SHIFT(NTYPE(J),ISURF,CURVEY,THICKNS,GLASS,NTYPE,
     *       ISTOP,NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,ICCY,ITHC,IGLC,
     *       RDECE,I1,I2,I3,I4,I6,J8)
C***  SHIFT DATA TO MAKE ROOM FOR 2ND GRATING SURFACE
            THICKNS(NTYPE(J))=0.0
            CALL SHIFT(NTYPE(J)+1,ISURF,CURVEY,THICKNS,GLASS,NTYPE,
     *       ISTOP,NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,ICCY,ITHC,IGLC,
     *       RDECE,I1,I2,I3,I4,I6,J8)
            RTILT(J9)=NTYPE(J)+1
C***   SHIFT DATA TO MAKE ROOM FOR 3RD GRATING SURFACE
            IF (Q .EQ. 1) THEN
              CALL SHIFT(NTYPE(J)+2,ISURF,CURVEY,THICKNS,GLASS,NTYPE,
     *         ISTOP,NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,ICCY,ITHC,IGLC,
     *         RDECE,I1,I2,I3,I4,I6,J8)     /* SHIFT DATA TO MAKE ROOM FOR
              THICKNS(NTYPE(J)+2)=THSAVE    /* DECENTER RETURN SURFACE IF IT
              IF ((ITHC(NTYPE(J)) .NE. 0) .AND.  /*EXISTS AND PUT THICKNESS HERE
     *            (ITHC(NTYPE(J)) .NE. 100)) THEN
                ITHC(NTYPE(J)+2)=ITHC(NTYPE(J))
                ITHC(NTYPE(J))=0  /*PICKUP UP STAYS WITH THICKNESS SURFACE
              END IF
              DO 160,K=1,J8
                IF (RDECE(K) .EQ. NTYPE(J)) RDECE(K)=RDECE(K)+2
160           CONTINUE
            ELSE
              THICKNS(NTYPE(J)+1)=THSAVE    /* THICKNESS GOES ON 2ND GRATING
              IF ((ITHC(NTYPE(J)) .NE. 0) .AND. /*SURFACE IF NOT DECENTER
     *            (ITHC(NTYPE(J)) .NE. 100)) THEN /*RETURN SURFACE.  PICKUP
                 ITHC(NTYPE(J)+1)=ITHC(NTYPE(J))  /*STAYS WITH THICKNESS
                 ITHC(NTYPE(J))=0                 /*SURFACE
              END IF
            END IF
C***  CASE 4: L=0  -1<M<1  -1<N<1
          ELSE IF ((AL(J) .EQ. 0.0) .AND. (ABS(AN(J)) .LT. 1.0)) THEN
            IF (DFIRST(NTYPE(J))) THEN  /* DFIRST SIGNALS A DECENTER & RETURN
C                                       /* WHICH TRANSLATES TO 2 SURFACES. THE
              DO 162,K=1,J8             /* GRT TRANSLATES TO 3 SURFACES BETWEEN
C*                                      /* THE DECENTER AND RETURN SURFACES
                IF (RDECE(K) .EQ. (NTYPE(J)+1)) Q=1
162           CONTINUE
              IF (Q .NE. 1)  /*MAKE ROOM FOR ONESHIFT IF RETURN DOESN'T EXIST
     *           CALL SHIFT(NTYPE(J)+1,ISURF,CURVEY,THICKNS,GLASS,
     *            NTYPE,ISTOP,NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,
     *            ICCY,ITHC,IGLC,RDECE,I1,I2,I3,I4,I6,J8)
              CALL ONESHIFT(NTYPE(J),CURVEY,THICKNS,GLASS,
     *         ISTOP,NAPERT,NSOLVE,ICCY,ITHC,IGLC,I1,I4,I6)
C**** SHIFT DATA TO MAKE ROOM FOR 1ST GRATING SURFACE
              ELSE
              Q=0
            END IF
            ANGLE=ATAN(AM(J)/AN(J))
            DIF(J)=(DIF(J)/SIN(ANGLE))
            J9=J9+1
            TILT(J9)=NTYPE(J)
            THETA(J9)=-90.0
            THSAVE=THICKNS(NTYPE(J))
            CALL SHIFT(NTYPE(J),ISURF,CURVEY,THICKNS,GLASS,NTYPE,
     *       ISTOP,NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,ICCY,ITHC,IGLC,
     *       RDECE,I1,I2,I3,I4,I6,J8)
C***  SHIFT DATA TO MAKE ROOM FOR 2ND GRATING SURFACE
            THICKNS(NTYPE(J))=0.0
            CALL SHIFT(NTYPE(J)+1,ISURF,CURVEY,THICKNS,GLASS,NTYPE,
     *       ISTOP,NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,ICCY,ITHC,IGLC,
     *       RDECE,I1,I2,I3,I4,I6,J8)
            RTILT(J9)=NTYPE(J)+1
C***   SHIFT DATA TO MAKE ROOM FOR 3RD GRATING SURFACE
            IF (Q .EQ. 1) THEN
              CALL SHIFT(NTYPE(J)+2,ISURF,CURVEY,THICKNS,GLASS,NTYPE,
     *         ISTOP,NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,ICCY,ITHC,IGLC,
     *         RDECE,I1,I2,I3,I4,I6,J8)     /* SHIFT DATA TO MAKE ROOM FOR
              THICKNS(NTYPE(J)+2)=THSAVE    /* DECENTER RETURN SURFACE IF IT
              IF ((ITHC(NTYPE(J)) .NE. 0) .AND.  /*EXISTS AND PUT THICKNESS HERE
     *            (ITHC(NTYPE(J)) .NE. 100)) THEN
                ITHC(NTYPE(J)+2)=ITHC(NTYPE(J))
                ITHC(NTYPE(J))=0  /*PICKUP UP STAYS WITH THICKNESS SURFACE
              END IF
              DO 165,K=1,J8
                IF (RDECE(K) .EQ. NTYPE(J)) RDECE(K)=RDECE(K)+2
165           CONTINUE
            ELSE
              THICKNS(NTYPE(J)+1)=THSAVE    /* THICKNESS GOES ON 2ND GRATING
              IF ((ITHC(NTYPE(J)) .NE. 0) .AND. /*SURFACE IF NOT DECENTER
     *            (ITHC(NTYPE(J)) .NE. 100)) THEN /*RETURN SURFACE.  PICKUP
                 ITHC(NTYPE(J)+1)=ITHC(NTYPE(J))  /*STAYS WITH THICKNESS
                 ITHC(NTYPE(J))=0                 /*SURFACE
              END IF
            END IF
C***  CASE 5: -1<L<1  M=0  -1<N<1
          ELSE IF ((AM(J) .EQ. 0.0) .AND. (ABS(AN(J)) .LT. 1.0)) THEN
            ANGLE=ATAN(AL(J)/AN(J))
            DIF(J)=(DIF(J)/COS(ANGLE))
C***  CASE 6: L=0  M=0  N=+-1.0
          ELSE IF (AL(J) .EQ. 0.0) THEN
            M=M+1
            MESSAGE(M)=5
            MESNUM(M)=NTYPE(J)   /* CANCEL GRATING; -1 AVOIDS PRINTING
            NTYPE(J)=-1          /* IN SUBROUTING OUTPUT2
C***  CASE 7: -1<L<1  -1<M<1  -1<N<1
          ELSE
            IF (DFIRST(NTYPE(J))) THEN  /* DFIRST SIGNALS A DECENTER & RETURN
C                                       /* WHICH TRANSLATES TO 2 SURFACES. THE
              DO 167,K=1,J8             /* GRT TRANSLATES TO 3 SURFACES BETWEEN
C*                                      /* THE DECENTER AND RETURN SURFACES
                IF (RDECE(K) .EQ. (NTYPE(J)+1)) Q=1
167           CONTINUE
              IF (Q .NE. 1)  /*MAKE ROOM FOR ONESHIFT IF RETURN DOESN'T EXIST
     *           CALL SHIFT(NTYPE(J)+1,ISURF,CURVEY,THICKNS,GLASS,
     *            NTYPE,ISTOP,NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,
     *            ICCY,ITHC,IGLC,RDECE,I1,I2,I3,I4,I6,J8)
              CALL ONESHIFT(NTYPE(J),CURVEY,THICKNS,GLASS,
     *         ISTOP,NAPERT,NSOLVE,ICCY,ITHC,IGLC,I1,I4,I6)
C**** SHIFT DATA TO MAKE ROOM FOR 1ST GRATING SURFACE
              ELSE
              Q=0
            END IF
            ANGLE=ATAN(AL(J)/AN(J))
            DIF(J)=(DIF(J)/SIN(ANGLE))
            J9=J9+1
            TILT(J9)=NTYPE(J)
            THETA(J9)=ATAN(AM(J)/AL(J))
            THSAVE=THICKNS(NTYPE(J))
            CALL SHIFT(NTYPE(J),ISURF,CURVEY,THICKNS,GLASS,NTYPE,
     *       ISTOP,NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,ICCY,ITHC,IGLC,
     *       RDECE,I1,I2,I3,I4,I6,J8)
C***  SHIFT DATA TO MAKE ROOM FOR 2ND GRATING SURFACE
            THICKNS(NTYPE(J))=0.0
            CALL SHIFT(NTYPE(J)+1,ISURF,CURVEY,THICKNS,GLASS,NTYPE,
     *       ISTOP,NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,ICCY,ITHC,IGLC,
     *       RDECE,I1,I2,I3,I4,I6,J8)
            RTILT(J9)=NTYPE(J)+1
C***   SHIFT DATA TO MAKE ROOM FOR 3RD GRATING SURFACE
            IF (Q .EQ. 1) THEN
              CALL SHIFT(NTYPE(J)+2,ISURF,CURVEY,THICKNS,GLASS,NTYPE,
     *         ISTOP,NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,ICCY,ITHC,IGLC,
     *         RDECE,I1,I2,I3,I4,I6,J8)     /* SHIFT DATA TO MAKE ROOM FOR
              THICKNS(NTYPE(J)+2)=THSAVE    /* DECENTER RETURN SURFACE IF IT
              IF ((ITHC(NTYPE(J)) .NE. 0) .AND.  /*EXISTS AND PUT THICKNESS HERE
     *            (ITHC(NTYPE(J)) .NE. 100)) THEN
                ITHC(NTYPE(J)+2)=ITHC(NTYPE(J))
                ITHC(NTYPE(J))=0  /*PICKUP UP STAYS WITH THICKNESS SURFACE
              END IF
              DO 170,K=1,J8
                IF (RDECE(K) .EQ. NTYPE(J)) RDECE(K)=RDECE(K)+2
170           CONTINUE
            ELSE
              THICKNS(NTYPE(J)+1)=THSAVE    /* THICKNESS GOES ON 2ND GRATING
              IF ((ITHC(NTYPE(J)) .NE. 0) .AND. /*SURFACE IF NOT DECENTER
     *            (ITHC(NTYPE(J)) .NE. 100)) THEN /*RETURN SURFACE.  PICKUP
                 ITHC(NTYPE(J)+1)=ITHC(NTYPE(J))  /*STAYS WITH THICKNESS
                 ITHC(NTYPE(J))=0                 /*SURFACE
              END IF
            END IF
          END IF
        END IF
175   CONTINUE
C******************************************************************************
C*****CURVATURE CONTROL CODES; Y-AXIS: ICCY
      DO 200,J=1,ISURF
        IF ((ABS(ICCY(J)) .LT. 100) .AND. (ABS(ICCY(J)) .GT. 0)) THEN
          J1=J1+1
          IPK(J1)=J
        ELSE IF ((ICCY(J) .LT. 200) .AND. (ICCY(J) .GT. 100)) THEN
          J3=J3+1
          ICOCYT(J3)=ICCY(J)-100
          ICOCYF(J3)=J
        END IF
200   CONTINUE
      CALL PICKUP(J1,ICCY,IPK,IPKCV1,IPKCV2,ICVA,J2,DUMMY,0)
C*****CURVATURE CONTROL; X-AXIS: ICCX
      J1=0
      DO 215,J=1,I4-1
        IF (TYPE(J) .NE. 'YTO') GOTO 215
        IF ((ABS(ICCX(J)) .LT. 100) .AND. (ABS(ICCX(J)) .GT. 0)) THEN
          J1=J1+1
          IPK(J1)=J
        ELSE IF ((ICCX(J) .LT. 200) .AND. (ICCX(J) .GT. 100)) THEN
          J6=J6+1
          ICOCXT(J6)=ICCX(J)-100
          ICOCXF(J6)=NTYPE(J)
        END IF
215   CONTINUE
      CALL PICKUP(J1,ICCX,IPK,IPKCV1,IPKCV2,ICVA,J2,NTYPE,1)
C******************************************************************************
C*****THICKNESS CONTROL CODES; ITHC
228   J1=0
      DO 230,J=1,ISURF
        IF ((ABS(ITHC(J)) .LT. 100) .AND. (ABS(ITHC(J)) .GT. 0)) THEN
          J1=J1+1
          IPK(J1)=J  /*DETERMINE SURFACES WITH PICKUPS
        END IF
230   CONTINUE
      CALL PICKUP(J1,ITHC,IPK,IPKTH1,IPKTH2,ITHA,J4,DUMMY,0)
C******************************************************************************
C*****GLASS CONTROL CODE: GLC
      J1=0
      DO 260,J=0,ISURF
        IF ((ABS(IGLC(J)) .LT. 100) .AND. (ABS(IGLC(J)) .GT. 0)) THEN
          J1=J1+1
          IPK(J1)=J
        END IF
260   CONTINUE
      CALL PICKUP(J1,IGLC,IPK,IPKGL1,IPKGL2,DUMMY,J5,DUMMY,0)
C*****ASPHERIC CONTROL CODES
C*****IAC
      J1=0
      DO 310,J=1,I4-1
        IF ((ABS(IAC(J)) .LT. 100) .AND. (ABS(IAC(J)) .GT. 0)) THEN
          J1=J1+1
          IPK(J1)=J
        END IF
310   CONTINUE
      CALL PICKUP(J1,IAC,IPK,IPKAD1,IPKAD2,IADA,JD,NTYPE,1)
C*****IBC
      J1=0
      DO 335,J=1,I4-1
        IF ((ABS(IBC(J)) .LT. 100) .AND. (ABS(IBC(J)) .GT. 0)) THEN
          J1=J1+1
          IPK(J1)=J
        END IF
335   CONTINUE
      CALL PICKUP(J1,IBC,IPK,IPKAE1,IPKAE2,IAEA,JE,NTYPE,1)
C*****ICC
      J1=0
      DO 360,J=1,I4-1
        IF ((ABS(ICC(J)) .LT. 100) .AND. (ABS(ICC(J)) .GT. 0)) THEN
          J1=J1+1
          IPK(J1)=J
        END IF
360   CONTINUE
      CALL PICKUP(J1,ICC,IPK,IPKAF1,IPKAF2,IAFA,JF,NTYPE,1)
C*****IDC
      J1=0
      DO 390,J=1,I4-1
        IF ((ABS(IDC(J)) .LT. 100) .AND. (ABS(IDC(J)) .GT. 0)) THEN
          J1=J1+1
          IPK(J1)=J
        END IF
390   CONTINUE
      CALL PICKUP(J1,IDC,IPK,IPKAG1,IPKAG2,IAGA,JG,NTYPE,1)
C*****KC
      J1=0
      DO 412,J=1,I4-1
        IF ((ABS(KC(J)) .LT. 100) .AND. (ABS(KC(J)) .GT. 0)) THEN
          J1=J1+1
          IPK(J1)=J
        END IF
412   CONTINUE
      CALL PICKUP(J1,KC,IPK,IPKCC1,IPKCC2,ICCA,JC,NTYPE,1)
C******************************************************************************
C*****DECENTER CONTROL CODES; IXDC
      J1=0
      DO 420,J=1,I2-1
        IF ((ABS(IXDC(J)) .LT. 100) .AND. (ABS(IXDC(J)) .GT. 0)) THEN
          J1=J1+1
          IPK(J1)=J
        END IF
420   CONTINUE
      CALL PICKUP(J1,IXDC,IPK,IPKX1,IPKX2,IXA,JX,NDECE,1)
C*****IYDC
      J1=0
      DO 450,J=1,I2-1
        IF ((ABS(IYDC(J)) .LT. 100) .AND. (ABS(IYDC(J)) .GT. 0)) THEN
          J1=J1+1
          IPK(J1)=J
        END IF
450   CONTINUE
      CALL PICKUP(J1,IYDC,IPK,IPKY1,IPKY2,IYA,JY,NDECE,1)
C*****IADC
      J1=0
      DO 480,J=1,I2-1
        IF ((ABS(IADC(J)) .LT. 100) .AND. (ABS(IADC(J)) .GT. 0)) THEN
          J1=J1+1
          IPK(J1)=J
        END IF
480   CONTINUE
      CALL PICKUP(J1,IADC,IPK,IPKA1,IPKA2,IAA,JA,NDECE,1)
C*****IBDC
      J1=0
      DO 510,J=1,I2-1
        IF ((ABS(IBDC(J)) .LT. 100) .AND. (ABS(IBDC(J)) .GT. 0)) THEN
          J1=J1+1
          IPK(J1)=J
        END IF
510   CONTINUE
      CALL PICKUP(J1,IBDC,IPK,IPKB1,IPKB2,IBA,JB,NDECE,1)
C*****ICDC
      J1=0
      DO 540,J=1,I2-1
        IF ((ABS(ICDC(J)) .LT. 100) .AND. (ABS(ICDC(J)) .GT. 0)) THEN
          J1=J1+1
          IPK(J1)=J
        END IF
540   CONTINUE
      CALL PICKUP(J1,ICDC,IPK,IPKG1,IPKG2,IGA,JM,NDECE,1)
C******************************************************************************
C*****WAVE LENGTHS AND WEIGHTS
      WVW1=WLF1/1000.0   /*CONVERT TO MICRONS
      WVW2=WLF2/1000.0  /*DEFAULT
      IWT1=IWTW1
      IWT2=IWTW2
      IF (WLF5 .GT. 0.0) THEN
        WVW1=WLF3/1000.0
        WVW2=WLF4/1000.0
        WVW3=WLF2/1000.0
        WVW4=WLF5/1000.0
        WVW5=WLF1/1000.0
        IWT1=IWTW3
        IWT2=IWTW4
        IWT3=IWTW2
        IWT4=IWTW5
        IWT5=IWTW1
      ELSE IF (WLF3 .GT. 0.0) THEN
        WVW1=WLF2/1000.0
        WVW2=WLF3/1000.0
        WVW3=WLF1/1000.0
        WVW4=WLF4/1000.0
        IWT1=IWTW2
        IWT2=IWTW3
        IWT3=IWTW1
        IWT4=IWTW4
      END IF
C******************************************************************************
C*****PRIVATE CATALOG WAVE LENGTHS AND INDICES OF REFRACTION
      DO 600,J=1,I5
        W1(J)=CATWL1(J)/1000.0
        W2(J)=CATWL2(J)/1000.0
        N1(J)=RFND1(J)
        N2(J)=RFND2(J)
        IF (CATWL5(J) .GT. 0.0) THEN
          W1(J)=CATWL3(J)/1000.0
          W2(J)=CATWL4(J)/1000.0
          W3(J)=CATWL2(J)/1000.0
          W4(J)=CATWL5(J)/1000.0
          W5(J)=CATWL1(J)/1000.0
          N1(J)=RFND3(J)
          N2(J)=RFND4(J)
          N3(J)=RFND2(J)
          N4(J)=RFND5(J)
          N5(J)=RFND1(J)
        ELSE IF (CATWL3(J) .GT. 0.0) THEN
          W1(J)=CATWL2(J)/1000.0
          W2(J)=CATWL3(J)/1000.0
          W3(J)=CATWL1(J)/1000.0
          W4(J)=CATWL4(J)/1000.0
          N1(J)=RFND2(J)
          N2(J)=RFND3(J)
          N3(J)=RFND1(J)
          N4(J)=RFND4(J)
        END IF
600   CONTINUE
C******************************************************************************
C*****REFRACTIVE INDICES
      DO 620,J=1,I7
        TWL1(J)=WL1(J)/1000.0
        TWL2(J)=WL2(J)/1000.0
        TIND1(J)=IND1(J)
        TIND2(J)=IND2(J)
        IF (WL5(J) .GT. 0.0) THEN
          TWL1(J)=WL3(J)/1000.0
          TWL2(J)=WL4(J)/1000.0
          TWL3(J)=WL2(J)/1000.0
          TWL4(J)=WL5(J)/1000.0
          TWL5(J)=WL1(J)/1000.0
          TIND1(J)=IND3(J)
          TIND2(J)=IND4(J)
          TIND3(J)=IND2(J)
          TIND4(J)=IND5(J)
          TIND5(J)=IND1(J)
        ELSE IF (WL3(J) .GT. 0.0) THEN
          TWL1(J)=WL2(J)/1000.0
          TWL2(J)=WL3(J)/1000.0
          TWL3(J)=WL1(J)/1000.0
          TWL4(J)=WL4(J)/1000.0
          TIND1(J)=IND2(J)
          TIND2(J)=IND3(J)
          TIND3(J)=IND1(J)
          TIND4(J)=IND4(J)
        END IF
620   CONTINUE
C******************************************************************************
C*****UNITS
      IF (DIM .EQ. 'I   ') THEN
        UNITS='INCHES'
      ELSE IF (DIM .EQ. 'M   ') THEN
        UNITS='MM'
      ELSE IF (DIM .EQ. 'C   ') THEN
        UNITS='CM'
      END IF
C******************************************************************************
C*****GLASS
      DO 640,J=0,ISURF
        IF ((GLASS(J)(8:12) .EQ. 'OHARA') .OR.
     *     (GLASS(J)(8:13) .EQ. 'SCHOTT') .OR.
     *     (GLASS(J)(8:11) .EQ. 'HOYA')) THEN
          GL(J)=GLASS(J)(8:13)//' '//GLASS(J)(1:6)
        ELSE IF ((GLASS(J)(1:3) .EQ. 'AIR') .OR.
     *      (GLASS(J)(1:4) .EQ. 'REFL')) THEN
          GL(J)=GLASS(J)
          ELSE IF (GLASS(J)(1:2) .EQ. '  ') THEN
            GL(J)='AIR'
          ELSE
          GL(J)='1'
          DO 630,K=1,I5
            IF (GLASS(J) .EQ. MATRL(K)) INDICE(J)=K
630       CONTINUE
        END IF
640   CONTINUE
C******************************************************************************
C*****MATRL GLASS
      DO 645,J=1,I7
        IF ((CATALOG(J)(8:12) .EQ. 'OHARA') .OR.
     *      (CATALOG(J)(8:13) .EQ. 'SCHOTT') .OR.
     *      (CATALOG(J)(8:11) .EQ. 'HOYA'))
     *      CATALOG(J)=CATALOG(J)(8:13)//' '//CATALOG(J)(1:6)
645   CONTINUE
C******************************************************************************
C*****APERTURES
      K=0
      DO 650,J=1,I1-1
        K=K+1
        IF (APERT(J) .EQ. 'CIR') THEN
          ICIR(K)=NAPERT(J)
          F1(K)=F1(J)
        ELSE IF (APERT(J) .EQ. 'REX') THEN
          IRECT(K)=NAPERT(J)
          F2(K)=F1(J)
          J=J+1
          F1(K)=F1(J)
        ELSE IF (APERT(J) .EQ. 'REY') THEN
          IRECT(K)=NAPERT(J)
          F1(K)=F1(J)
          J=J+1
          F2(K)=F1(J)
        ELSE IF (APERT(J) .EQ. 'ELX') THEN
          IELIP(K)=NAPERT(J)
          F2(K)=F1(J)
          J=J+1
          F1(K)=F1(J)
        ELSE IF (APERT(J) .EQ. 'ELY') THEN
          IELIP(K)=NAPERT(J)
          F1(K)=F1(J)
          J=J+1
          F2(K)=F1(J)
        END IF
650   CONTINUE
      NUMA=K
C******************************************************************************
C*****SOLVES
      DO 800,J=1,I6-1
        IF (SOLVE1(J) .EQ. 'CUY') GOTO 770
        IF (SOLVE1(J) .EQ. 'CUX') GOTO 780
        IF (SOLVE1(J) .EQ. 'PIM') SOLVE(J)='PY'
C*****THICKNESS SOLVES
        IF (SOLVE2(J) .EQ. 'MRY') THEN
          SOLVE(J)='PY'
        ELSE IF (SOLVE2(J) .EQ. 'CRY') THEN
          SOLVE(J)='PCY'
        ELSE IF (SOLVE2(J) .EQ. 'MRX') THEN
          SOLVE(J)='PX'
        ELSE IF (SOLVE2(J) .EQ. 'CRX') THEN
          SOLVE(J)='PCX'
        END IF
        GOTO 800
C*****CURVATURE SOLVES: Y-AXIS
770     IF (SOLVE2(J) .EQ. 'MRY') THEN
          SOLVE(J)='PUY'
        ELSE IF (SOLVE2(J) .EQ. 'CRY') THEN
          SOLVE(J)='PUCY'
        ELSE IF (SOLVE2(J) .EQ. 'IMY') THEN
          SOLVE(J)='PIY'
        ELSE IF (SOLVE2(J) .EQ. 'ICY') THEN
          SOLVE(J)='PICY'
        ELSE IF (SOLVE2(J) .EQ. 'AMY') THEN
          SOLVE(J)='APY'
        ELSE IF (SOLVE2(J) .EQ. 'ACY') THEN
          SOLVE(J)='APCY'
        END IF
        GOTO 800
C*****CURVATURE SOLVES: X-AXIS
780     IF (SOLVE2(J) .EQ. 'MRX') THEN
          SOLVE(J)='PUX'
        ELSE IF (SOLVE2(J) .EQ. 'CRX') THEN
          SOLVE(J)='PUCX'
        ELSE IF (SOLVE2(J) .EQ. 'IMX') THEN
          SOLVE(J)='PIX'
        ELSE IF (SOLVE2(J) .EQ. 'ICX') THEN
          SOLVE(J)='PICX'
        ELSE IF (SOLVE2(J) .EQ. 'AMX') THEN
          SOLVE(J)='APX'
        ELSE IF (SOLVE2(J) .EQ. 'ACX') THEN
          SOLVE(J)='APCX'
        END IF
800   CONTINUE
C******************************************************************************
C*****ANALYSIS DATA
      UCHIEF=UCHIEF*(360/(2*3.1415927))
      RETURN
      END
      SUBROUTINE OUTPUT2
C
C*****THIS SUBROUTINE WRITES AN ACCOSV LENS DECK
C
C** COMMON BLOCK BOTH DECLARATIONS
      CHARACTER*4 SOLVE(40)
      CHARACTER*13 GLASS(0:225)
      CHARACTER*64 TITLE
      INTEGER*4 I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,M,ISTOP,IREF,ISURF
      INTEGER*4 NAPERT(225),NDECE(100),NSOLVE(40),NUMA,MESSAGE(20)
      REAL*4 DIF(66)
      REAL*8 ADE(100),BDE(100),CDE(100),XDE(100),YDE(100),CURVEY(0:225)
      REAL*8 THICKNS(0:225),RK(66),A(66),B(66),C(66),D(66),SOLVF1(40)
      REAL*8 F1(225)
      LOGICAL AFO,IC(66),CUF(66)
C** COMMON BLOCK ACCOSV DECLARATIONS
      CHARACTER*6 UNITS
      INTEGER*4 IORDER(66),IWT1,IWT2,IWT3,IWT4,IWT5
      REAL*4 WVW1,WVW2,WVW3,WVW4,WVW5,WT1,WT2,WT3,WT4,WT5,THETA(66)
      REAL*4 RN1
      REAL*8 N1(20),N2(20),N3(20),N4(20),N5(20),F2(225)
C** COMMON BLOCK CAONLY DECLARATIONS
      CHARACTER*3 SURFMES(20),SOLVE1(40),SOLVE2(40)
      CHARACTER*4 TYPE(66)
      CHARACTER*13 CATALOG(20),MATRL(20),GL(0:225)
      CHARACTER*24 SUBMES4(20)
      INTEGER*4 NTYPE(66),NRETUT(100),NRETUF(100),IPKCV1(200)
      INTEGER*4 IPKAD1(200),IPKAD2(200),IPKAE1(200),IPKAE2(200)
      INTEGER*4 IPKAF1(200),IPKAF2(200),IPKAG1(200),IPKAG2(200)
      INTEGER*4 IPKA1(200),IPKA2(200),IPKB1(200),IPKB2(200),IPKG1(200)
      INTEGER*4 IPKG2(200),IPKX1(200),IPKX2(200),IPKY1(200),IPKY2(200)
      INTEGER*4 IPKGL1(200),IPKGL2(200),IPKTH1(200),IPKTH2(200)
      INTEGER*4 IPKCC1(200),IPKCC2(200),ICCA(200),ICVA(200),ITHA(200)
      INTEGER*4 IGLA(200),IAEA(200),IAFA(200),IAGA(200),IADA(200)
      INTEGER*4 IXA(200),IYA(200),IAA(200),IBA(200),IGA(200),J1,J2,J3
      INTEGER*4 J4,J5,J6,J7,J8,J9,JE,JF,JG,JD,JX,JY,JA,JB,JM
      INTEGER*4 INDICE(225),ICIR(225),IRECT(225),IELIP(225),ICOCYF(20)
      INTEGER*4 ICOCYT(20),ICOCXF(20),ICOCXT(20),TILT(66),RTILT(66)
      INTEGER*4 RDECE(100),MESNUM(20),IPKCV2(200)
      REAL*4 WL1(20),WL2(20),WL3(20),WL4(20),WL5(20),WL6(20),WL7(20)
      REAL*4 TWL1(20),TWL2(20),TWL3(20),TWL4(20),TWL5(20)
      REAL*4 CATWL1(20),CATWL2(20),CATWL3(20),CATWL4(20),CATWL5(20)
      REAL*4 CATWL6(20),CATWL7(20),W1(20),W2(20),W3(20),W4(20),W5(20)
      REAL*4 IND1(20),IND2(20),IND3(20),IND4(20),IND5(20),TIND1(20)
      REAL*4 TIND2(20),TIND3(20),TIND4(20),TIND5(20)
      REAL*8 UMARG,YMARG,UCHIEF,CUX(30),RADE(100),RBDE(100)
      REAL*8 RCDE(100),RXDE(100),RYDE(100)
      LOGICAL VIGNET,TEL,RETURN(100),ZMFLAG
C** LOCAL DECLARATIONS
      CHARACTER*4 FLAG1,FLAG2
      REAL*45 FLAG4,FLAG3
C
      COMMON /BOTH/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,GLASS,MESSAGE,M,
     *        ISTOP,IREF,ISURF,AFO,NAPERT,NDECE,F1,DIF,ADE,BDE,CDE,XDE,
     *        YDE,CURVEY,THICKNS,RK,A,B,C,D,IC,CUF,NSOLVE,SOLVF1,SOLVE,
     *        TITLE,NUMA
      COMMON /ACCOSV/IORDER,WVW1,WVW2,WVW3,WVW4,WVW5,WT1,WT2,WT3,WT4,
     *        WT5,IWT1,IWT2,IWT3,IWT4,IWT5,THETA,F2,RN1,UNITS,N1,
     *        N2,N3,N4,N5
      COMMON /CAONLY/UMARG,YMARG,UCHIEF,YCHIEF,TYPE,NTYPE,NRETUT,
     *        NRETUF,CATWL1,CATWL2,CATWL3,CATWL4,CATWL5,CATWL6,CATWL7,
     *        CUX,VIGNET,TEL,RETURN,MATRL,SOLVE1,SOLVE2,ZMFLAG,SURFMES,
     *        CATALOG,WL1,WL2,WL3,WL4,WL5,WL6,WL7,IND1,IND2,IND3,IN4,
     *        IND5,TWL1,TWL2,TWL3,TWL4,TWL5,TIND1,TIND2,TIND3,TIND4,
     *        TIND5,GL,IPKCV1,IPKCV2,IPKAD1,IPKAD2,IPKAE1,IPKAE2,
     *        IPKAF1,IPKAF2,IPKAG1,IPKAG2,IPKA1,IPKA2,IPKB1,IPKB2,
     *        IPKG1,IPKG2,IPKX1,IPKX2,IPKY1,IPKY2,IPKTH1,IPKTH2,IPKCC1,
     *        IPKCC2,ICCA,ICVA,ITHA,IGLA,IAEA,IAFA,IAGA,IADA,IXA,IYA,
     *        IAA,IBA,IGA,J1,J2,J3,J4,J5,J6,J7,J8,J9,JE,JF,JG,JD,JX,JY,
     *        JA,JB,JM,INDICE,ICIR,IRECT,IELIP,ICOCYF,ICOCYT,ICOCXF,
     *        ICOCXT,TILT,RTILT,W1,W2,W3,W4,W5,RDECE,RADE,RBDE,RCDE,
     *        RXDE,RYDE,MESNUM,SUBMES4
C******************************************************************************
C*****FORMAT STATEMENTS
  2   FORMAT(1X,A8,F14.7,2X,F14.7)
  4   FORMAT(1X,A8)
  6   FORMAT(1X,A6,A60)
  8   FORMAT(1X,A8,E14.7)
  9   FORMAT(1X,A8,F14.7)
 10   FORMAT(1X,A8,6X,F8.6,3X,F8.6,3X,F8.6,3X,F8.6,3X,F8.6)
 11   FORMAT(1X,A8,I4)
 12   FORMAT(1X,A6,A6,A1)
 13   FORMAT(1X,A8,10X,I4,7X,I4,7X,I4,7X,I4,7X,I4)
 14   FORMAT(1X,A11)
 16   FORMAT(1X,A14,F8.6,3X,F8.6,3X,F8.6,3X,F8.6,3X,F8.6)
 18   FORMAT(1X,A8,E14.7,1X,E14.7,1X,E14.7,1X,E14.7)
 20   FORMAT(1X,A8,F14.7,2X,F14.7,2X,F14.7)
 22   FORMAT(1X,A13,I4,2X,I4)
 24   FORMAT(1X,A13,I4)
 26   FORMAT(1X,A12,2X,I4)
 28   FORMAT(1X,A10,F12.7)
 30   FORMAT(1X,A10,F12.7,4X,F12.7)
 31   FORMAT(1X,A4,4X,F14.7)
 32   FORMAT(1X,A29)
 34   FORMAT(1X,A13)
 36   FORMAT(1X,A6,A6,2X,F8.6,3X,F8.6,3X,F8.6,3X,F8.6,3X,F8.6)
 38   FORMAT(1X,A46)
 40   FORMAT(1X,A61)
 42   FORMAT(1X,A47)
 44   FORMAT(1X,A24,A3,A33)
 46   FORMAT(1X,A32,I4,A20)
 48   FORMAT(1X,A75)
 49   FORMAT(1X,A47,A15)
 50   FORMAT(1X,A8,A24)
C******************************************************************************
C*****STANDARD DATA - WRITTEN ONCE PER LENS DECK
      WRITE(5,6)'LENS  ',TITLE
      WRITE(5,9)'SAY     ',YMARG
      WRITE(5,2)'SCY FANG',UCHIEF,YCHIEF
      WRITE(5,10)'WV      ',WVW1,WVW2,WVW3,WVW4,WVW5
      IF (IREF .GT. 0) WRITE(5,11)'CW      ',IREF
      IF (DIM .NE. ' ') WRITE(5,12)'UNITS ',UNITS
      IF (AFO) WRITE(5,14)'MODE AFOCAL'
C******************************************************************************
C*****MAIN LOOP IS EXECUTED ONCE FOR EACH SURFACE
      DO 500,L=0,ISURF
        WRITE(5,8)'CV      ',CURVEY(L)
        WRITE(5,8)'TH      ',THICKNS(L)
        IF (L .EQ. ISTOP) THEN
          WRITE(5,4)'ASTOP   '
          WRITE(5,4)'REFS    '
        END IF
        DO 95,K=1,I5
          IF (CATALOG(K) .EQ. GLASS(L)) THEN
            WRITE(5,16)'MELT WV       ',W1(K),W2(K),W3(K),W4(K),W5(K)
            WRITE(5,16)'MELT INDICES  ',N1(K),N2(K),N3(K),N4(K),N5(K)
          END IF
 95     CONTINUE
C******************************************************************************
C*****TILTS AND RTILTS
        DO 100,K=1,J9
          IF (TILT(K) .EQ. L) WRITE(5,20)'TILT    ',0.0,0.0,THETA(K)
          IF (RTILT(K) .EQ. L) WRITE(5,20)'RTILT   ',0.0,0.0,THETA(K)
100     CONTINUE
C******************************************************************************
C*****SPECIAL SURFACES
        DO 200,K=1,I4-1
          IF (NTYPE(K) .EQ. L) THEN
            IF (TYPE(K) .EQ. 'CYL') GOTO 150
            WRITE(5,18)'ASPH    ',A(K),B(K),C(K),D(K)
            WRITE(5,9)'CC      ',RK(K)
            IF (IC(K)) WRITE(5,4)'ASI     '
            IF (CUF(K)) WRITE(5,4)'FRNL    '
            IF (TYPE(K) .EQ. 'YTO') THEN
150           WRITE(5,9)'CVY     ',CUX(K)
            ELSE IF (TYPE(K) .EQ. 'GRT') THEN
              WRITE(5,9)'GRATY   ',DIF(K)
              WRITE(5,13)'GORD    ',IORDER(K),IORDER(K),IORDER(K),
     *          IORDER(K),IORDER(K)
             END IF
          END IF
200     CONTINUE
C******************************************************************************
C*****PICK UP CONTROL CODES
C*****CURVATURE PICKUPS
        DO 220,K=1,J2
          IF (IPKCV2(K) .EQ. L) WRITE(5,22)'PIKUP CV     ',IPKCV1(K),
     *      ICVA(K)
220     CONTINUE
        DO 225,K=1,J3
          IF (ICOCYF(K) .EQ. L) WRITE(5,24)'COCY         ',ICOCYT(K)
225     CONTINUE
        DO 230,K=1,J6
          IF (ICOCXF(K) .EQ. L) WRITE(5,24)'COCX         ',ICOCXT(K)
230     CONTINUE
C*****THICKNESS PICKUPS
        DO 235,K=1,J4
          IF (IPKTH2(K) .EQ. L) WRITE(5,22)'PIKUP TH     ',IPKTH1(K),
     *      ITHA(K)
235     CONTINUE
C*****GLASS PICKUPS
        DO 240,K=1,J5
          IF (IPKGL2(K) .EQ. L) WRITE(5,24)'PIKUP GLASS  ',IPKGL1(K)
240     CONTINUE
C*****ASPHERIC PICKUPS
        DO 245,K=1,JD
          IF (IPKAD2(K) .EQ. L) WRITE(5,22)'PIKUP AD     ',IPKAD1(K),
     *      IADA(K)
245     CONTINUE
        DO 250,K=1,JE
          IF (IPKAE2(K) .EQ. L) WRITE(5,22)'PIKUP AE     ',IPKAE1(K),
     *      IAEA(K)
250     CONTINUE
        DO 255,K=1,JF
          IF (IPKAF2(K) .EQ. L) WRITE(5,22)'PIKUP AF     ',IPKAF1(K),
     *      IAFA(K)
255     CONTINUE
        DO 260,K=1,JG
          IF (IPKAG2(K) .EQ. L) WRITE(5,22)'PIKUP AG     ',IPKAG1(K),
     *      IAGA(K)
260     CONTINUE
        DO 265,K=1,JC
          IF (IPKCC2(K) .EQ. L) WRITE(5,22)'PIKUP CC     ',IPKCC1(K),
     *      ICCA(K)
265     CONTINUE
C*****DECENTER PICKUPS
        DO 270,K=1,JX
          IF (IPKX2(K) .EQ. L) WRITE(5,22)'PIKUP XD     ',IPKX1(K),
     *      IXA(K)
270     CONTINUE
        DO 275,K=1,JY
          IF (IPKY2(K) .EQ. L) WRITE(5,22)'PIKUP YD     ',IPKY1(K),
     *      IYA(K)
275     CONTINUE
        DO 280,K=1,JA
          IF (IPKA2(K) .EQ. L) WRITE(5,22)'PIKUP ALPHA  ',IPKA1(K),
     *      IAA(K)
280     CONTINUE
        DO 285,K=1,JB
          IF (IPKB2(K) .EQ. L) WRITE(5,22)'PIKUP BETA   ',IPKB1(K),
     *      IBA(K)
285     CONTINUE
        DO 290,K=1,JM
          IF (IPKG2(K) .EQ. L)WRITE(5,22)'PIKUP GAMMA  ',IPKG1(K),
     *      IGA(K)
290     CONTINUE
C******************************************************************************
C*****DECENTERED SURFACES; INITIAL DECENTER
        DO 300,K=1,I2-1
          IF (NDECE(K) .EQ. L) THEN
           WRITE(5,2)'DEC     ',YDE(K),XDE(K)
           WRITE(5,20)'TILT    ',ADE(K),BDE(K),CDE(K)
          END IF
300     CONTINUE
C******************************************************************************
C*****DECENTERED SURFACES WITH RETURNS
        DO 305,K=1,J8
          IF (RDECE(K) .EQ. L) THEN
            WRITE(5,20)'RTILT   ',RADE(K),RBDE(K),RCDE(K)
            WRITE(5,2)'DEC     ',RYDE(K),RXDE(K)
          END IF
305     CONTINUE
C******************************************************************************
C*****RETURN ONLY SURFACE
        IF (I2 .LE. 1) GOTO 331
        DO 330,J=1,I3-1
         IF (NRETUF(J) .EQ. L) THEN           /* TRACING BACK THROUGH EACH
          DO 310,KK=(I2-1),1,-1               /* TILT AND DECNTER AND REVERSING
            IF ((NDECE(KK) .LT. NRETUF(J)) .AND. /* THEM IF A RETURN HAS NOT
     *        (NDECE(KK) .GT. NRETUT(J)) .AND.   /* OCCURRED
     *        (.NOT. RETURN(KK))) THEN
                WRITE(5,20)'RTILT   ',ADE(KK),BDE(KK),CDE(KK)
                WRITE(5,2)'DEC     ',-YDE(KK),-XDE(KK)
              END IF
310         CONTINUE
         END IF
330     CONTINUE
C******************************************************************************
C*****APERTURES
331     DO 335,K=1,NUMA
          IF (F1(K) .EQ. ABS(F1(K))) GOTO 332
            IF (ICIR(K) .EQ. L) THEN
              WRITE(5,28)'COBS      ',-F1(K)
            ELSE IF (IRECT(K) .EQ. L) THEN
              WRITE(5,30)'COBS RECT ',-F1(K),-F2(K)
            ELSE IF (IELIP(K) .EQ. L) THEN
              WRITE(5,30)'COBS ELIP ',-F1(K),-F2(K)
            END IF
          GOTO 335
332         IF (ICIR(K) .EQ. L) THEN
              WRITE(5,28)'CLAP      ',F1(K)
            ELSE IF (IRECT(K) .EQ. L) THEN
              WRITE(5,30)'CLAP RECT ',F1(K),F2(K)
            ELSE IF (IELIP(K) .EQ. L) THEN
              WRITE(5,30)'CLAP ELIP ',F1(K),F2(K)
            END IF
335     CONTINUE
C******************************************************************************
C*****SOLVES
        DO 350,K=1,I6-1
          IF (NSOLVE(K) .EQ. L) WRITE(5,31)SOLVE(K),SOLVF1(K)
350     CONTINUE
C******************************************************************************
C*****MATERIAL
      IF (GL(L)(1:1) .NE. '1') THEN
        WRITE(5,34)GL(L)
      ELSE
        WRITE(5,36)'GLASS ',GLASS(L)(1:6),TIND1(INDICE(L)),
     *   TIND2(INDICE(L)),TIND3(INDICE(L)),TIND4(INDICE(L)),
     *   TIND5(INDICE(L))
      END IF
500   CONTINUE  /* END MAIN LOOP
C******************************************************************************
C*****END LENS
      WRITE(5,4)'EOS     '
      IF (IWT1 .GT. 0.0) WRITE(5,10)'SPTWT   ',IWT1,IWT2,IWT3,IWT4,IWT5
C*****WRITE MESSAGES
      WRITE(5,32)'C  .....END OF LENS DECK.....'
      DO 550,K=1,M-1
        IF (MESSAGE(K) .EQ. 1) THEN
          WRITE(5,38)'C  .....Vignetting is not available in ACCOSV.'
        ELSE IF (MESSAGE(K) .EQ. 2) THEN
          WRITE(5,40)'C  .....Telecentric System option is not ',
     *     'available in ACCOSV.'
        ELSE IF (MESSAGE(K) .EQ. 3) THEN
          WRITE(5,42)'C  .....ZOOM option is not available in ACCOSV.'
        ELSE IF (MESSAGE(K) .EQ. 4) THEN
          WRITE(5,44)'C  .....Special Surface ',SURFMES(K),
     *      ' cannot be translated for ACCOSV.'
        ELSE IF (MESSAGE(K) .EQ. 5) THEN
          WRITE(5,46)'C  .....Check grating on surface',MESNUM(K),
     *      ' and enter it manually.'
        ELSE IF (MESSAGE(K) .EQ. 6) THEN
          WRITE(5,48)'C  .....Zero thickness on surface 0 is not ',
     *      'allowed.  Surface 0 was deleted.'
        ELSE IF (MESSAGE(K) .EQ. 7) THEN
          WRITE(5,49)'C  .....The following aperture data line cannot',
     *     ' be translated.'
          WRITE(5,50)'C  .....',SUBMES4(K)
        END IF
550   CONTINUE
      RETURN
      END
C
      SUBROUTINE SHIFT(L,ISURF,CURVEY,THICKNS,GLASS,NTYPE,ISTOP,
     *  NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,ICCY,ITHC,IGLC,RDECE,
     *  I1,I2,I3,I4,I6,J8)
C*****THIS SUBROUTINE SHIFTS ALL ARRAY VALUES READ FROM THE INPUT FILE
C*****ONE POSITION TO ALLOW FOR AN EXTRA SURFACE TO BE ADDED. THIS NEED
C*****IS CREATED BY TILTS WITH RETURNS AND GRATINGS.
C
      INTEGER*4 L,ISURF,NTYPE(66),ISTOP,NDECE(100),NRETUT(100)
      INTEGER*4 NRETUF(100),NAPERT(225),NSOLVE(40),ICCY(0:225)
      INTEGER*4 ITHC(0:225),IGLC(0:225),RDECE(100),I1,I2,I3,I4,I6,J8
      REAL*8 CURVEY(0:225),THICKNS(0:225)
      CHARACTER*13 GLASS(0:225)
C
      DO 100,K=ISURF,L,-1
        CURVEY(K+1)=CURVEY(K)
        THICKNS(K+1)=THICKNS(K)
        GLASS(K+1)=GLASS(K)
        ICCY(K+1)=ICCY(K)
        ITHC(K+1)=ITHC(K)
        IGLC(K+1)=IGLC(K)
100   CONTINUE
      ISURF=ISURF+1
      CURVEY(L)=0.0
      THICKNS(L)=0.0
      ICCY(L)=0
      ITHC(L)=0
      IGLC(L)=0
      GLASS(L)='        '
      IF (ISTOP .GE. L) ISTOP=ISTOP+1
      DO 175,K=1,I3-1
        IF (NRETUT(K) .GE. L) NRETUT(K)=NRETUT(K)+1
        IF (NRETUF(K) .GE. L) NRETUF(K)=NRETUF(K)+1
175   CONTINUE
      DO 200,K=1,I1-1
        IF (NAPERT(K) .GE. L) NAPERT(K)=NAPERT(K)+1
200   CONTINUE
      DO 225,K=1,I6-1
        IF (NSOLVE(K) .GE. L) NSOLVE(K)=NSOLVE(K)+1
225   CONTINUE
      DO 250,K=1,J8
        IF (RDECE(K) .GE. L) RDECE(K)=RDECE(K)+1
250   CONTINUE
      DO 260,K=1,I2-1
        IF (NDECE(K) .GE. L) NDECE(K)=NDECE(K)+1
260   CONTINUE
      DO 275,K=1,I4-1
        IF (NTYPE(K) .GE. L) NTYPE(K)=NTYPE(K)+1
275   CONTINUE
      RETURN
      END
C
      SUBROUTINE ONESHIFT(L,CURVEY,THICKNS,GLASS,ISTOP,
     *  NAPERT,NSOLVE,ICCY,ITHC,IGLC,I1,I4,I6)
C*****THIS SUBROUTINE SHIFTS DATA FROM ONE SURFACE TO THE NEXT SURFACE.
C*****THIS IS A SINGLE SURFACE SHIFT. THIS NEED IS CREATED BY A DECENTER
C*****WITH A GRATING.
C
      INTEGER*4 L,ISTOP,NAPERT(225),NSOLVE(40),ICCY(0:225)
      INTEGER*4 ITHC(0:225),IGLC(0:225),I1,I4,I6
      REAL*8 CURVEY(0:225),THICKNS(0:225)
      CHARACTER*13 GLASS(0:225)
C
      CURVEY(L+1)=CURVEY(L)
      THICKNS(L+1)=THICKNS(L)
      GLASS(L+1)=GLASS(L)
      ICCY(L+1)=ICCY(L)
      ITHC(L+1)=ITHC(L)
      IGLC(L+1)=IGLC(L)
      CURVEY(L)=0.0
      THICKNS(L)=0.0
      ICCY(L)=0
      ITHC(L)=0
      IGLC(L)=0
      GLASS(L)='        '
      IF (ISTOP .EQ. L) ISTOP=ISTOP+1
      DO 200,K=1,I1-1
        IF (NAPERT(K) .EQ. L) NAPERT(K)=NAPERT(K)+1
200   CONTINUE
      DO 225,K=1,I6-1
        IF (NSOLVE(K) .EQ. L) NSOLVE(K)=NSOLVE(K)+1
225   CONTINUE
      L=L+1
      RETURN
      END
C
      SUBROUTINE PICKUP(J1,ICODE,IPK,IPK1,IPK2,IA,J,N,L)
C*****THIS SUBROUTINE CONVERTS CONTROL CODES TO PICKUS BY FINDING THE SURFACE
C*****TO PICKUP FROM AND THE SURFACE TO PICKUP TO
      INTEGER*4 J1,J,ICODE(0:225),IPK(200),IPK1(200),IPK2(200),IA(200)
      INTEGER*4 N(100),L
C
      DO 200,K=1,J1
        DO 100,KK=(K+1),J1
          J=J+1
          IF (ABS(ICODE(IPK(K)-L)) .EQ. ABS(ICODE(IPK(KK)-L))) THEN
            IF (N(1) .EQ. 0) THEN /* DUMMY ARRAY PASSED
              IPK1(J)=IPK(K)              /* L CORRECTS FOR THE DIFFERENT
              IPK2(J)=IPK(KK)            /* DIMENSIONS OF ICCY,ITH,IGLC
            ELSE                        /* COMPARED TO THE OTHER CONTROL
              IPK1(J)=N(IPK(K))          /* CODE ARRAYS.
              IPK2(J)=N(IPK(KK))
            END IF
          ELSE
            GOTO 100
          END IF
          IF (ICODE(IPK(K)-L) .NE. ICODE(IPK(KK)-L)) THEN
            IA(J)=-1
          ELSE
            IA(J)=1
          END IF
          ICODE(IPK(KK)-L)=0 /*RESET TO AVOID A DOUBLE PICKUP
100     CONTINUE
200   CONTINUE
      RETURN
      END
C
C
      SUBROUTINE ZEROSHIFT(ISURF,CURVEY,THICKNS,GLASS,NTYPE,ISTOP,
     *  NDECE,NRETUT,NRETUF,NAPERT,NSOLVE,ICCY,ITHC,IGLC,I1,I2,I3,
     *  I4,I6)
C*****THIS SUBROUTINE SHIFTS ALL SURFACES FORWARD SO THAT SURFACE ONE
C*****BECOMES SURFACE 0, 2 BECOMES 1, ETC.  THIS IS NECESSARY IF THE
C*****THICKNESS ON SURFACE 0 EQUALS 0.
C
      INTEGER*4 ISURF,NTYPE(66),ISTOP,NDECE(100),NRETUT(100)
      INTEGER*4 NRETUF(100),NAPERT(225),NSOLVE(40),ICCY(0:225)
      INTEGER*4 ITHC(0:225),IGLC(0:225),I1,I2,I3,I4,I6
      REAL*8 CURVEY(0:225),THICKNS(0:225)
      CHARACTER*13 GLASS(0:225)
C
      DO 100,K=0,ISURF-1
        CURVEY(K)=CURVEY(K+1)
        THICKNS(K)=THICKNS(K+1)
        GLASS(K)=GLASS(K+1)
        ICCY(K)=ICCY(K+1)
        ITHC(K)=ITHC(K+1)
        IGLC(K)=IGLC(K+1)
100   CONTINUE
      ISURF=ISURF-1
      ISTOP=ISTOP-1
      DO 150,K=1,I2-1
        NDECE(K)=NDECE(K)-1
150   CONTINUE
      DO 175,K=1,I3-1
        NRETUT(K)=NRETUT(K)-1
        NRETUF(K)=NRETUF(K)-1
175   CONTINUE
      DO 200,K=1,I6-1
        NSOLVE(K)=NSOLVE(K)-1
200   CONTINUE
      DO 225,K=1,I4-1
        NTYPE(K)=NTYPE(K)-1
225   CONTINUE
      DO 250,K=1,I1-1
        NAPERT(K)=NAPERT(K)-1
250   CONTINUE
      RETURN
      END
